home *** CD-ROM | disk | FTP | other *** search
/ Merciful 5 / Merciful - Disc 5.iso / software / p / pcqpascalv1.2d.lha / Examples2 / Fade / fade.p < prev   
Encoding:
Text File  |  1997-05-06  |  6.0 KB  |  218 lines
  1.  
  2. { -----------------------------------------------------------------------
  3.   -                                    -
  4.   -  Fade  -  Version 1.1,           (C)1991  by  Bernd Künnen    -
  5.   -                            Neuringe 75    -
  6.   -   This programm is Freeware,            44777 Twist    -
  7.   -   coded 25.10.1991 in PCQ-Pascal(1.2b).                -
  8.   -   Blendet Texte zeilenweise ein & aus.                -
  9.   -   Wichtig: Jede Zeile muß mit einem RETURN        Usage :        -
  10.   -   abgeschlossen werden - nur ASCII-Texte                -
  11.   -   verwenden.                    Fade filename    -
  12.   -                                    -
  13.   -----------------------------------------------------------------------
  14. }
  15.  
  16. Program Fade;
  17.  
  18. {$I "include:libraries/dos.i"       }
  19. {$I "include:Intuition/screens.i"  }
  20. {$I "include:intuition/intuition.i"}
  21. {$I "include:graphics/Pens.i"       }
  22. {$I "include:Utils/parameters.i"   }
  23. {$I "include:graphics/Graphics.i"  }
  24. {$I "include:exec/exec.i"       }
  25. {$I "include:Utils/stringlib.i"    }
  26.  
  27.  
  28. CONST
  29.     rgb  : Integer = 0;
  30.  
  31.     MaxSize = 1000;        {##  max. Filegröße 999 Byte }
  32.  
  33.     NewWin : NewWindow  =  (0,0,640,150,0,1,0,
  34.                 BORDERLESS + BACKDROP + ACTIVATE,
  35.                 NIL,NIL,NIL,NIL,NIL,0,0,0,0,CUSTOMSCREEN_f);
  36.  
  37.     NewScr : NewScreen  =  (0,0,640,150,1,0,1,HIRES,CUSTOMSCREEN_f,
  38.                 NIL,NIL,NIL,NIL);
  39.  
  40.  
  41. VAR
  42.     MyVPort        : Address;
  43.     MyRPort        : Address;
  44.     Win        : WindowPtr;
  45.     Scr        : ScreenPtr;
  46.     MyMem        : Address;
  47.     MyLock        : FileLock;
  48.     MyHandle    : FileHandle;
  49.     anzahl,
  50.     filesize    : Integer;
  51.     x,y,i        : Short;
  52.     WorkPtr,stop    : Address;
  53.     fib        : FileInfoBlockPtr;
  54.     myfile        : String;
  55.     buffer        : ARRAY[0..99] OF Byte;
  56.     ok        : Boolean;
  57.  
  58.  
  59. { **** Sorgt für ein sauberes Verlassen des Programms, egal wo man  ****
  60.   **** aussteigt :                            **** }
  61.  
  62. PROCEDURE cleanexit(why : String ; rtcode : Integer);
  63.  
  64. BEGIN
  65.     IF Win     <> NIL THEN CloseWindow(Win);
  66.     IF Scr     <> NIL THEN CloseScreen(Scr);
  67.     IF MyMem   <> NIL THEN FreeMem(MyMem,MaxSize);
  68.     IF GfxBase <> NIL THEN CloseLibrary(GfxBase);
  69.  
  70.         { ## Ausgabe ins CLI, warum das Program verlassen }
  71.         { ## werden mußte, inkl.Returncode f. Batchfiles  }
  72.     IF why<>NIL THEN writeln(why);
  73.     exit(rtcode);
  74. END;
  75.  
  76.  
  77.  
  78. { ****  Hier die Ein- & Ausblenderoutine, beschränkt sich allerdings  ****
  79.   ****  dato auf Schwarz/Weiß.                          **** }
  80.  
  81. PROCEDURE fade(color: Short; x : Integer);
  82. BEGIN
  83.     FOR i:=0 TO 12 DO BEGIN            { 13mal wird f. Einfaden 1,}
  84.       rgb:=rgb+x;                { f. Abblenden -1 addiert  }
  85.       SetRGB4(MyVPort,color,rgb,rgb,rgb);    { und die Summe als Farbe  }
  86.       Delay(3);                { übergeben           }
  87.     END;
  88. END;
  89.  
  90.  
  91.  
  92. { ****  Da PCQ-Pascal nicht die Addition einer Integer-Zahl zu einer  ****
  93.   ****  Adresse erlaubt, muß man halt ein wenig tricksen. Diese Rou-  ****
  94.   ****  tine übernimmt eine Adresse, addiert einen Offset und gibt    ****
  95.   ****  die neue Adresse in d0 zurück                      **** }
  96.  
  97. Function SetPtr(XPtr: Address; add: Integer): Address;
  98. BEGIN
  99. {$A
  100.     move.l    8(sp),d0    ; Assemblerkenntnisse sind
  101.     add.l    4(sp),d0    ; immer wieder nützlich
  102. }
  103. END;
  104.  
  105.  
  106.  
  107. { ****  Little bit tricky - hier wird nach einem RETURN (#$0a = 10 )  ****
  108.   ****  im übergebenen String gesucht und die Stringlänge zurückge-   ****
  109.   ****  geben. In PCQ zu umständlich, da strlen() nach einem NullByte ****
  110.   ****  sucht etc.                              **** }
  111.  
  112. Function SeekRETURN(ghi: Address): Integer;
  113. BEGIN
  114. {$A
  115.     move.l    4(sp),d1    ; WorkPtr nach d1 und a0
  116.     move.l    d1,a0
  117. seek:
  118.     cmp.b    #$0a,(a0)+
  119.     bne.s    seek        ; RETURN suchen
  120.     subq.l    #1,a0        ; a0 berichtigen
  121.     move.l    a0,d0        ; Endadr. nach d0
  122.     sub.l    d1,d0        ; Anfangsadr. abziehen
  123. }
  124. END;
  125.  
  126.  
  127. { **************  Hier nun endlich die Hauptschleife  ************** }
  128.  
  129. BEGIN
  130.   myfile:=Adr(buffer);        { ## Filename in Buffer kopieren }
  131.   GetParam(1,myfile);
  132.   IF strlen(myfile)=0 THEN cleanexit(" Fade 1.1,(C)1991 B.Künnen - Usage : fade filename",0);
  133.  
  134.   GfxBase:=OpenLibrary("graphics.library",0);
  135.   IF GfxBase=NIL THEN cleanexit("Can`t open Gfx.lib.",20);
  136.  
  137.   { ##  Im nächsten Schritt werden 1000 Bytes alloziert. Dieser Bereich wird
  138.     zunächst als Speicher für den FileInfoBlock benutzt, und dann ggf.
  139.     als Buffer für das File benutzt. }
  140.  
  141.   MyMem:=AllocMem(MaxSize,MEMF_PUBLIC);
  142.   IF MyMem=NIL THEN cleanexit("No Mem.",5);
  143.  
  144.   MyLock:=Lock(myfile,SHARED_LOCK);
  145.   IF MyLock=NIL THEN cleanexit("Can`t get lock.",5);
  146.   fib:=MyMem;
  147.   ok:=Examine(MyLock,fib);
  148.   Unlock(MyLock);
  149.  
  150.   IF ok=FALSE THEN cleanexit("Can`t examine file",10);
  151.   IF fib^.fib_EntryType>0 THEN cleanexit("Need file, no Dir.",5);
  152.  
  153.   { ##    Größe des Files holen & File laden .... }
  154.  
  155.   filesize:=fib^.fib_Size;
  156.   IF filesize=0    THEN cleanexit("File empty.",5);
  157.   IF filesize>MaxSize-1 THEN cleanexit("File too big.",5);
  158.  
  159.   MyHandle:=DOSOpen(myfile,MODE_OLDFILE);
  160.   IF MyHandle=NIL THEN cleanexit("Can`t open file.",5);
  161.   anzahl:=DOSRead(MyHandle,MyMem,filesize);
  162.   DOSClose(MyHandle);
  163.   IF anzahl<>filesize THEN cleanexit("Error reading file.",5);
  164.  
  165.   { ##    Um den Programmabschluß abzusichern, ...    }
  166.   WorkPtr:=SetPtr(MyMem,filesize);
  167.   {$A
  168.     move.l    _WorkPtr,a0    ; sicherheitshalber hinter den
  169.     move.b    #$0a,(a0)    ; Text noch ein RETURN
  170.   }
  171.  
  172.   Scr:=OpenScreen(Adr(NewScr));
  173.   IF Scr=NIL THEN cleanexit("Can`t open Screen.",5);
  174.   MyVPort:=Adr(Scr^.SViewPort);
  175.   SetRGB4(MyVPort,0,0,0,0);    { ## Screen & Window, Titlebar  }
  176.   SetRGB4(MyVPort,1,0,0,0);    {    unsichtbar, alles schwarz, }
  177.   ShowTitle(Scr,FALSE);
  178.  
  179.   NewWin.Screen:=Scr;
  180.   Win:=OpenWindow(Adr(NewWin));
  181.   IF Win=NIL THEN cleanexit("Can`t open window.",5);
  182.   MyRPort:=Win^.RPort;
  183.   SetDrMd(MyRPort,JAM1);
  184.  
  185.   { ##    Jetzt geht`s ans Eingemachte. Zuerst Ptr(Anfang/Ende) holen. }
  186.  
  187.   WorkPtr:=MyMem;
  188.   stop:=SetPtr(MyMem,filesize);
  189.  
  190.   REPEAT
  191.     anzahl:=SeekRETURN(WorkPtr);    { Länge des 1. String holen }
  192.  
  193.     IF (anzahl<>0) AND (anzahl<70) THEN BEGIN
  194.  
  195.       x:=320-4*anzahl;        { x-Position ermitteln, zum }
  196.       SetAPen(MyRPort,1);        { Zentrieren d. Strings,der }
  197.       Move(MyRPort,x,120);        { mit Col. 1 (noch schwarz) }
  198.       GText(MyRPort,WorkPtr,anzahl); { gedruckt wird        }
  199.  
  200.       fade(1,1);            { Aufblenden    }
  201.       Delay(40);            { 0,8 sec warten}
  202.       fade(1,-1);            { Abblenden    }
  203.       Delay(40);
  204.  
  205.       SetAPen(MyRPort,0);            { A-Pen auf Col.0 }
  206.       RectFill(MyRPort,0,100,639,140);    {  alles löschen  }
  207.  
  208.     END; { if }
  209.  
  210.     WorkPtr:=SetPtr(WorkPtr, anzahl+1);    { nächster String }
  211.  
  212.   UNTIL WorkPtr=stop;            { bis Ende des Buffers erreicht }
  213.  
  214.   Delay(100);                { 2 taktvolle Sekunden ...... }
  215.   cleanexit(NIL,0);            { bye bye baby .... }
  216.  
  217. END.
  218.